home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / drives.swg / 0025_Edit Disk Serial Number.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-07-16  |  3.7 KB  |  139 lines
  1. PROGRAM Serial (Input, Output);
  2. USES CRT;
  3.  
  4. CONST
  5.   HexDigits : ARRAY [0..15]OF CHAR = '0123456789ABCDEF';
  6. TYPE
  7.   InfoBuffer = RECORD
  8.                InfoLevel : WORD;    {should be zero}
  9.                Serial : LONGINT;
  10.                VolLabel : ARRAY [0..10]OF CHAR;
  11.                FileSystem : ARRAY [0..7]OF CHAR;
  12.              END;
  13.   SerString = STRING [9];
  14.  
  15. VAR
  16.   IB : InfoBuffer;
  17.   N : WORD;
  18.   let : CHAR;
  19.   param : STRING [10];
  20.   IsSet : BOOLEAN;
  21.   NewSerial : LONGINT;
  22.   code : INTEGER;
  23.  
  24.   FUNCTION SerialStr (L : LONGINT) : SerString;
  25.   VAR Temp : SerString;
  26.   BEGIN
  27.     Temp [0] := #9;
  28.     Temp [1] := HexDigits [L SHR 28];
  29.     Temp [2] := HexDigits [ (L SHR 24) AND $F];
  30.     Temp [3] := HexDigits [ (L SHR 20) AND $F];
  31.     Temp [4] := HexDigits [ (L SHR 16) AND $F];
  32.     Temp [5] := '-';
  33.     Temp [6] := HexDigits [ (L SHR 12) AND $F];
  34.     Temp [7] := HexDigits [ (L SHR 8) AND $F];
  35.     Temp [8] := HexDigits [ (L SHR 4) AND $F];
  36.     Temp [9] := HexDigits [L AND $F];
  37.     SerialStr := Temp;
  38.   END;
  39.  
  40.   FUNCTION GetSerial (DiskNum : BYTE;
  41.                      VAR I : InfoBuffer) : WORD;assembler;
  42.     asm
  43.     MOV AH, 69h
  44.     MOV AL, 00h
  45.     MOV BL, DiskNum
  46.     PUSH DS
  47.     LDS DX, I
  48.     INT 21h
  49.     POP DS
  50.     JC @Bad
  51.     XOR AX, AX
  52.     @Bad :
  53.     END;
  54.  
  55.     FUNCTION SetSerial (DiskNum : BYTE;
  56.                        VAR I : InfoBuffer) : WORD;assembler;
  57.       asm
  58.       MOV AH, 69h
  59.       MOV AL, 00h
  60.       MOV BL, DiskNum
  61.       PUSH DS
  62.       LDS DX, I
  63.       INT 21h
  64.       POP DS
  65.       JC @Bad
  66.       XOR AX, AX
  67.       @Bad :
  68.       END;
  69.  
  70.       PROCEDURE ErrorOut (err : BYTE);
  71.       BEGIN
  72.         CASE err OF
  73.           5 : BEGIN
  74.               WRITELN ('Either the disk in ', let, ': is write',
  75.                       'protected or it lacks an extended BPB.');
  76.               WRITELN ('If the disk is not write-protected, ',
  77.                       'reformat it with DOS 4 or higher.');
  78.             END;
  79.           15 : WRITELN ('Not a valid drive letter.');
  80.           255 : BEGIN
  81.                 WRITELN ('SYNTAX:   SERIAL D:########"');
  82.                 WRITELN ('  where D: is the drive letter',
  83.                         'and ######## is the eight digit');
  84.                 WRITELN ('  hexadecimal serial number with-',
  85.                         'out the "-".');
  86.                 WRITELN ('EXAMPLE:  SERIAL A: 1234ABCD');
  87.               END;
  88.  
  89.         ELSE WRITELN ('DOS ERROR #', N);
  90.         END;
  91.         HALT (1);
  92.       END;
  93.  
  94.     BEGIN
  95.       CLRSCR;
  96.       IF PARAMCOUNT < 1 THEN ErrorOut (255);
  97.       IF PARAMCOUNT > 2 THEN ErrorOut (255);
  98.       param := PARAMSTR (1);
  99.       CASE LENGTH (param) OF
  100.         1 : {OK};
  101.         2 : IF param [2] <> ':' THEN ErrorOut (255);
  102.       ELSE ErrorOut (255);
  103.       END;
  104.       let := UPCASE (param [1]);
  105.       IF (let < 'A') OR (let > 'Z') THEN ErrorOut (15);
  106.       IF PARAMCOUNT < 2 THEN IsSet := FALSE
  107.       ELSE
  108.         BEGIN
  109.           IsSet := TRUE;
  110.           param := '$' + PARAMSTR (2);
  111.           VAL (param, NewSerial, code);
  112.           IF code <> 0 THEN ErrorOut (255);
  113.         END;
  114.       N := GetSerial (ORD (let) - ORD ('@'), IB);
  115.       IF N = 0 THEN
  116.         BEGIN
  117.           WITH IB DO
  118.             BEGIN
  119.               WRITELN ('Serial Number is "',
  120.                       SerialStr (Serial), '"');
  121.               IF IsSet THEN
  122.                 BEGIN
  123.                   Serial :=
  124.                   NewSerial; ;
  125.                   N :=
  126.                   SetSerial (ORD (let) - ORD ('@'), IB);
  127.                   IF N = 0 THEN
  128.  
  129.                     WRITELN ('Successfully canged serial to "', SerialStr (NewSerial), '"')
  130.                   ELSE
  131.                     ErrorOut (N);
  132.                 END;
  133.             END;
  134.         END
  135.       ELSE ErrorOut (N);
  136.  
  137.     END.
  138.  
  139.